home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / CUGUK / C048.ZIP / ALISP.ZIP / LISP.C next >
Text File  |  1985-08-06  |  17KB  |  735 lines
  1. #include <stdio.h>
  2. #include <ctype.h>
  3. #include "lisp.h"
  4.  
  5. int _stack = 5000;
  6.  
  7. LIST *TRU;
  8. LIST *alist;
  9. LIST *oblist;
  10.  
  11. char progon;
  12.  
  13.  
  14. FILE *fd;     /* input file descriptor */
  15.  
  16.  
  17. /********************************************************/
  18. /*            main program            */
  19. /********************************************************/
  20.  
  21. main()
  22. {
  23.   initialize();
  24.   load_library();
  25.  
  26.   printf("\t\tMarc Adler's LISP Interpreter\n");
  27.   fd = stdin;
  28.   interpret();
  29. }
  30.  
  31.  
  32.  
  33. interpret()
  34. {
  35.   LIST *p, *q;   register int c;
  36.  
  37.   while ((c = gettok()) != EOF) {
  38.     switch (c) {
  39.       case LPAREN   : getc(fd);   /* span the paren */
  40.               q = makelist();
  41.               p = eval(q, alist);
  42.               break;
  43.  
  44.       case LETTER   : p = cdr(car(getid()));
  45.               break;
  46.     }
  47.  
  48.     if (fd == stdin) {
  49.       printf("value => ");
  50.       if (p == NULL) printf("nil");
  51.       else lisp_print(cons(p, NULL));
  52.       printf("\n");
  53.     }
  54.   }
  55. }
  56.  
  57.  
  58.  
  59. /******************************************************************/
  60. /*           initialization proceedures              */
  61. /******************************************************************/
  62.  
  63. initialize()
  64. {
  65.   init("'", QUOTE);        init("car", FCAR);
  66.   init("cond", COND);           init("cdr", FCDR);
  67.   init("defun", DEFUN);         init("cons",FCONS);
  68.   init("nil", NILL);            init("atom",FATOM);
  69.   init("prog",PROG);            init("eq",  FEQ);
  70.   init("go",  GO);              init("setq",FSETQ);
  71.   init("return",RETRN);         init("print",PRINT);
  72.   init("read", FREAD);
  73.   init("rplaca",FREPLACA);      init("rplacd",FREPLACD);
  74.   init("apply", FAPPLY);        init("eval",  FEVAL);
  75.   init("and", FAND);            init("or", FOR);
  76.   init("not", FNOT);
  77.   init("plus",  PLUS);          init("zerop", ZEROP);
  78.   init("diff",  DIFF);          init("greaterp", GREATERP);
  79.   init("times", TIMES);         init("lessp", LESSP);
  80.   init("add1",  ADD1);          init("sub1",  SUB1);
  81.   init("quot",  QUOTIENT);      TRU = cons(init("t",T), NULL);
  82.   init("numberp",NUMBERP);      rplact(TRU, SATOM);
  83.   init("null",  NUL);           init("funcall",FUNCALL);
  84.  
  85.   oblist = alist;
  86. }
  87.  
  88.  
  89. LIST *init(name, t)
  90.   char *name;  int t;
  91. {
  92.   register LIST *p;
  93.  
  94.   p = install(name);
  95.   rplact(p, t);
  96.   return(p);
  97. }
  98.  
  99.  
  100. /******************************************************************/
  101. /*     create the executable list form of a LISP program      */
  102. /******************************************************************/
  103.  
  104. LIST *makelist()
  105. {
  106.   register LIST *p;
  107.  
  108.   switch (gettok()) {
  109.     case LPAREN   : getc(fd);    /* span the paren ????? */
  110.             p = makelist();
  111.             p = cons(p, makelist());
  112.             rplact(p, LST);
  113.             return(p);
  114.  
  115.     case LETTER   : p = getid();
  116.             return(cons(p, makelist()));
  117.  
  118.     case INQUOTE  : p = getid();
  119.             p = cons(p, makelist());
  120.             rplaca(p, cons(car(p), cons(car(cdr(p)), NULL)));
  121.             rplacd(p, cdr(cdr(p)));
  122.             return(p);
  123.  
  124.     case DIGIT    : p = getnum();
  125.             return(cons(p, makelist()));
  126.  
  127.     case RPAREN   : getc(fd);    /* span rparen ?????? */
  128.             return(NULL);
  129.   }
  130. }
  131.  
  132.  
  133. /* lisp_print - walks along the list structure printing atoms */
  134. lisp_print(p)
  135.   register LIST *p;
  136. {
  137.   char *getname();
  138.  
  139.   if (p != NULL)
  140.  
  141.     if (type(p) == RATOM)    printf("%f ", p->u.num);
  142.     else if (type(p) == IATOM)    printf("%d ", (int) p->u.num);
  143.     else if (type(p) == SATOM)    printf("%s ", getname(car(p)));
  144.     else if (type(car(p)) == LST) {
  145.       putchar('(');
  146.       lisp_print(car(p));
  147.       putchar(')');
  148.       lisp_print(cdr(p));
  149.     }
  150.     else if (type(p) == LST) {
  151.       lisp_print(car(p));
  152.       lisp_print(cdr(p));
  153.     }
  154.     else
  155.       printf("******** can't print it out *******\n");
  156. }
  157.  
  158.  
  159. /******************************************************************/
  160. /*            evaluate a LISP function              */
  161. /******************************************************************/
  162.  
  163. LIST *eval(x, alist)
  164.   register LIST *x, *alist;
  165. {
  166.   register LIST *p, *q;  int savt, t;   char *getname();
  167.  
  168.   if (x == NULL)  return(NULL);
  169.   t = type(x);
  170.   if (t == VARI) return(assoc(alist, getname(car(x))));
  171.   if (t == IATOM || t == RATOM) return(x);
  172.   if (t == LABL) return(NULL);
  173.  
  174.   switch (type(car(x))) {
  175.  
  176.     case T      : return(TRU);
  177.  
  178.     case NILL    : return(NULL);
  179.  
  180.     case QUOTE    : var_to_atom(car(cdr(x)));
  181.               return(car(cdr(x)));
  182.  
  183.     case FCAR    : return(car(eval(cdr(x), alist)));
  184.  
  185.     case FCDR    : return(cdr(eval(cdr(x), alist)));
  186.  
  187.     case FATOM    : return(atom(eval(cdr(x), alist)));
  188.  
  189.     case FEQ    : return(eq(eval(car(cdr(x)),alist),
  190.                     eval(cdr(cdr(x)),alist)));
  191.  
  192.     case NUL    : return(eq(eval(car(cdr(x)), alist), NULL));
  193.  
  194.     case FCONS    : return(cons(eval(car(cdr(x)),alist),
  195.                       eval(cdr(cdr(x)), alist)));
  196.  
  197.     case FLIST    : return(_list(x));
  198.  
  199.     case COND    : return(evalcond(cdr(x), alist));
  200.  
  201.     case FSETQ    : p = eval(cdr(cdr(x)), alist);
  202.               rplacd(getvar(alist, getname(car(car(cdr(x))))), p);
  203.               return(p);
  204.  
  205.     case DEFUN    : rplact(car(car(cdr(x))), FUSER);
  206.               rplacd(car(car(cdr(x))), cdr(cdr(x)));
  207.               var_to_user(cdr(cdr(cdr(x))));
  208.               if (fd == stdin)
  209.                 printf("%s\n", getname(car(car(cdr(x)))));
  210.               return(NULL);
  211.  
  212.     case FUSER    : p = cdr(car(car(x)));   /* p is statement list */
  213.               return( eval(car(cdr(p)),
  214.             pairargs(car(p),evalargs(cdr(x),alist),alist,FALSE)));
  215.  
  216.     case FAPPLY    :
  217.     case FUNCALL    : p = eval(car(cdr(x)), alist);   /* func name */
  218.               if (isfunc( savt = type(car(p)) )) {
  219.                 p = cons(p, cdr(cdr(x)));
  220.                 if (savt == FUSER)
  221.                   rplact(car(p), FUSER);
  222.                 q = eval(p, alist);
  223.                 rplact(car(p), savt);
  224.                 return(q);
  225.               }
  226.               else return(NULL);
  227.  
  228.  
  229.     case FEVAL    : p = eval(cdr(x), alist);
  230.               if (type(p) == SATOM)
  231.                 return(assoc(alist, getname(car(p))));
  232.               else
  233.                 return(eval(p, alist));
  234.  
  235.     case PRINT    : lisp_print(eval(car(cdr(x)), alist));
  236.               putchar('\n');
  237.               return(NULL);
  238.  
  239.     case FREAD    : return(makelist());
  240.  
  241.     case FAND    : return(_and(x));
  242.     case FOR    : return(_or(x));
  243.     case FNOT    : return(_not(x));
  244.  
  245.     case PLUS    :
  246.     case DIFF    :
  247.     case TIMES    :
  248.     case QUOTIENT    :
  249.     case GREATERP    :
  250.     case LESSP    :  return(arith(car(x), eval(car(cdr(x)),alist),
  251.                         eval(cdr(cdr(x)),alist)));
  252.  
  253.     case ADD1    :
  254.     case SUB1    :return(arith(car(x), eval(car(cdr(x)),alist),NULL));
  255.  
  256.     case ZEROP    : p = eval(car(cdr(x)), alist);
  257.               return( (p->u.num == 0) ? TRU : NULL);
  258.  
  259.     case NUMBERP    : savt = type(eval(car(cdr(x)), alist));
  260.               return( (savt==IATOM || savt==RATOM) ? TRU : NULL);
  261.  
  262.     case PROG    : return(evalprog(x, alist));
  263.  
  264.     case GO     : return(cdr(car(car(cdr(x)))));
  265.  
  266.     case RETRN    : progon = FALSE;
  267.               return(eval(cdr(x), alist));
  268.  
  269.     case LST    : if (cdr(x) == NULL) return(eval(car(x), alist));
  270.               return(cons(eval(car(x),alist),eval(cdr(x),alist)));
  271.  
  272.     case VARI    : return(assoc(alist, getname(car(car(x)))));
  273.  
  274.     case IATOM    :
  275.     case RATOM    : return(car(x));
  276.  
  277.   } /* switch */
  278. }
  279.  
  280.  
  281. LIST *evalcond(expr, alist)
  282.   LIST *expr, *alist;
  283. {
  284.   if (expr == NULL)  return(NULL);
  285.   if (eval(car(car(expr)), alist) != NULL)     /* expr was true */
  286.     return(eval(car(cdr(car(expr))), alist));  /* return result */
  287.   return(evalcond(cdr(expr), alist));           /* eval rest of args */
  288. }
  289.  
  290.  
  291. LIST *evalprog(p, alist)
  292.   LIST *p, *alist;
  293. {
  294.   register LIST *x;
  295.  
  296.   /* set up parameters as locals */
  297.   alist = pairargs(car(cdr(p)), cons(NULL, NULL), alist, TRUE);
  298.   progon = TRUE;
  299.   p = cdr(cdr(p));     /* p now points to the statement list */
  300.   find_labels(p);     /* set up all labels in the prog */
  301.  
  302.   while (p != NULL && progon) {
  303.     x = eval(car(p), alist);
  304.     if (type(car(car(p))) == GO)
  305.       p = x;         /* GO returned the next statement to go to */
  306.     else
  307.       p = cdr(p);     /* just follow regular chain of statements */
  308.   }
  309.  
  310.   progon = TRUE;     /* in case of nested progs */
  311.   return(x);
  312. }
  313.  
  314.  
  315. /* pairargs - installs parameters in the alist, and sets the value to be */
  316. /*          the value of the corresponding argument             */
  317. LIST *pairargs(params, args, alist, prog)
  318.   LIST *params, *args, *alist;    int prog;
  319. {
  320.   register LIST *p;
  321.  
  322.   if (params == NULL)     /* no more args to be evaluated */
  323.     return(alist);
  324.  
  325.   p = cons(NULL, car(args));  /* value of param is corresponding arg */
  326.   p->u.pname = getname(car(car(params)));
  327.   rplact(p, VARI);
  328.   if (prog)
  329.     return(cons(p, pairargs(cdr(params), cons(NULL,NULL), alist, prog)));
  330.   else
  331.     return(cons(p, pairargs(cdr(params), cdr(args),      alist, prog)));
  332. }
  333.  
  334.  
  335. LIST *evalargs(arglist, alist)
  336.   LIST *arglist, *alist;
  337. {
  338.   if (arglist == NULL) return(NULL);
  339.   return(cons(eval(car(arglist),alist), evalargs(cdr(arglist), alist)));
  340. }
  341.  
  342.  
  343. LIST *assoc(alist, name)
  344.   LIST *alist;    char *name;
  345. {
  346.   return(cdr(getvar(alist, name)));
  347. }
  348.  
  349. LIST *getvar(alist, name)
  350.   LIST *alist;    char *name;
  351. {
  352.   return(lookup(alist, name));
  353. }
  354.  
  355.  
  356. /* arith - performs arithmetic on numeric items */
  357. LIST *arith(op, x, y)
  358.   LIST *op, *x, *y;
  359. {
  360.   LIST *p;  float res;   int t = type(op);
  361.  
  362.   if (t == LESSP) return((x->u.num < y->u.num) ? TRU : NULL);
  363.   if (t == GREATERP) return ((x->u.num > y->u.num) ? TRU : NULL);
  364.  
  365.   switch (t) {
  366.     case PLUS   : res = x->u.num + y->u.num;  break;
  367.     case DIFF   : res = x->u.num - y->u.num;  break;
  368.     case TIMES  : res = x->u.num * y->u.num;  break;
  369.     case QUOTIENT:res = x->u.num / y->u.num;  break;
  370.     case ADD1   : res = x->u.num + 1;       break;
  371.     case SUB1   : res = x->u.num - 1;       break;
  372.   }
  373.  
  374.   p = cons(NULL, NULL);
  375.   if (type(x) == IATOM && (type(y) == IATOM || t == ADD1 || t == SUB1)) {
  376.     p->u.num = (int) res;  rplact(p, IATOM);
  377.   }
  378.   else {
  379.     p->u.num = res;       rplact(p, RATOM);
  380.   }
  381.   return(p);
  382. }
  383.  
  384.  
  385.  
  386.  
  387. /******************************************************************/
  388. /*                input functions              */
  389. /******************************************************************/
  390.  
  391. /* advance - skips white space in input file */
  392. advance()
  393. {
  394.   register int c;  char *strchr();
  395.  
  396.   while ((c=getc(fd)) != EOF && strchr(" \t\n",c) != NULL) ;
  397.   ungetc(c, fd);
  398.   return (c);
  399. }
  400.  
  401. LIST *lookup(head, name)
  402.   LIST *head;  char *name;
  403. {
  404.   register LIST *p;   char *getname();
  405.  
  406.   for (p = head; p != NULL && strcmp(name,getname(car(p))); p = cdr(p))
  407.     ;
  408.   return ((p == NULL) ? NULL : car(p));
  409. }
  410.  
  411. LIST *install(name)
  412.   char *name;
  413. {
  414.   register LIST *p;   char *emalloc();
  415.  
  416.   p = cons(NULL, NULL);
  417.   strcpy(p->u.pname = emalloc(strlen(name)+1), name);
  418.   rplact(p, VARI);
  419.   alist = cons(p, alist);
  420.   return(p);
  421. }
  422.  
  423. LIST *getnum()
  424. {
  425.   register LIST *p;    float sum, n;  int c;
  426.  
  427.   sum = 0.0;
  428.   p = cons(NULL, NULL);
  429.   rplact(p, IATOM);
  430.  
  431.   while (isdigit(c = getc(fd)))
  432.     sum = sum * 10 + c - '0';
  433.  
  434.   if (c == '.') {     /* the number is real */
  435.     n = 10;
  436.     rplact(p, RATOM);
  437.     while (isdigit(c = getc(fd))) {
  438.       sum += (c - '0')/n;
  439.       n *= 10;
  440.     }
  441.   }
  442.  
  443.   ungetc(c, fd);
  444.   p->u.num = sum;
  445.   return(p);
  446. }
  447.  
  448.  
  449. LIST *getid()
  450. {
  451.   char inbuf[120];
  452.   register LIST *p, *idptr;   int c;   register char *s = inbuf;
  453.  
  454.  *s++ = c = getc(fd);
  455.  if (c != '\'') {
  456.    for ( ; isalnum(c=getc(fd)); *s++ = c) ;
  457.    ungetc(c, fd);
  458.  }
  459.  *s = '\0';
  460.  
  461.  if ((idptr = lookup(oblist,inbuf)) == NULL)     /* not a LISP function */
  462.    if ((idptr = lookup(alist,inbuf)) == NULL)     /* id not declared yet */
  463.      idptr = install(inbuf);             /* install it in alist */
  464.  
  465.  p = cons(idptr, NULL);
  466.  rplact(p, type(idptr));
  467.  return(p);
  468. }
  469.  
  470.  
  471. gettok()
  472. {
  473.   char c, buf[120];
  474.  
  475.   while ((c = advance()) == ';')     /* saw a comment */
  476.     fgets(buf, 120, fd);         /* eat the rest of the line */
  477.   if (isalpha(c))
  478.     return(LETTER);
  479.   if (isdigit(c))
  480.     return(DIGIT);
  481.   switch (c) {
  482.     case '('    : return(LPAREN);
  483.     case ')'    : return(RPAREN);
  484.     case '\''   : return(INQUOTE);
  485.     default    : return(ERR);
  486.   }
  487. }
  488.  
  489.  
  490. /*****************************************************************/
  491. /*             LISP primitive functions             */
  492. /*****************************************************************/
  493.  
  494. /* new - gets a new node from the free storage */
  495. LIST *new()
  496. {
  497.   register LIST *p;  char *emalloc();
  498.  
  499.   p = (struct LIST *) emalloc(sizeof(LIST));
  500.   p->gcbit = RUNNING;
  501. }
  502.  
  503. type(p)
  504.   register LIST *p;
  505. {
  506.   return((int) p->htype);
  507. }
  508.  
  509. char *getname(p)
  510.   register LIST *p;
  511. {
  512.   return((p == NULL) ? NULL : p->u.pname);
  513. }
  514.  
  515. rplaca(p, q)
  516.   register LIST *p, *q;
  517. {
  518.   p->left = q;
  519. }
  520.  
  521. rplacd(p, q)
  522.   register LIST *p, *q;
  523. {
  524.   p->right = q;
  525. }
  526.  
  527. rplact(p, t)
  528.   register LIST *p;  int t;
  529. {
  530.   p->htype = t;
  531. }
  532.  
  533. LIST *car(p)
  534.   register LIST *p;
  535. {
  536.   return((p == NULL) ? NULL : p->left);
  537. }
  538.  
  539. LIST *cdr(p)
  540.   register LIST *p;
  541. {
  542.   return((p == NULL) ? NULL : p->right);
  543. }
  544.  
  545. LIST *cons(p, q)
  546.   register LIST *p, *q;
  547. {
  548.   register LIST *x;
  549.  
  550.   x = new();
  551.   rplaca(x, p);
  552.   rplacd(x, q);
  553.   rplact(x, LST);
  554.   return(x);
  555. }
  556.  
  557. LIST *eq(x, y)
  558.   register LIST *x, *y;
  559. {
  560.   if (x == NULL || y == NULL) {
  561.     if (x == y) return(TRU);
  562.   }
  563.   else if (type(x) == SATOM && type(y) == SATOM && car(x) == car(y))
  564.     return(TRU);
  565.   return(NULL);
  566. }
  567.  
  568. LIST *atom(x)
  569.   register LIST *x;
  570. {
  571.   register int typ;
  572.  
  573.   if (x == NULL || (typ = type(x)) == IATOM || typ == RATOM || typ == SATOM)
  574.     return(TRU);
  575.   return(NULL);
  576. }
  577.  
  578.        /* logical connectives - and, or, not */
  579.  
  580. LIST *_and(x)
  581.   register LIST *x;
  582. {
  583.   register LIST *p;
  584.   for (p = cdr(x);  p != NULL;  p = cdr(p))
  585.     if (eval(car(p)) == NULL)  return(NULL);
  586.   return(TRU);
  587. }
  588.  
  589. LIST *_or(x)
  590.   LIST *x;
  591. {
  592.   register LIST *p;
  593.   for (p = cdr(x);  p != NULL;  p = cdr(p))
  594.     if(eval(car(p)) != NULL)  return(TRU);
  595.   return(NULL);
  596. }
  597.  
  598. LIST *_not(x)
  599.   LIST *x;
  600. {
  601.   return (eval(cdr(x)) == NULL) ? TRU : NULL;
  602. }
  603.  
  604.  
  605.            /* other primitives */
  606.  
  607. LIST *_list(x)
  608.   LIST *x;
  609. {
  610.   LIST *res, *p;
  611.  
  612.   for (res = NULL, p = cdr(x);    p != NULL;  p = cdr(p))
  613.     res = cons(res, car(p));
  614.   return(res);
  615. }
  616.  
  617.  
  618. var_to_user(p)
  619.   register LIST *p;
  620. {
  621.   if (p != NULL)
  622.     if (type(p) == VARI) {
  623.       if (type(car(p)) == FUSER)
  624.     rplact(p, FUSER);
  625.     }
  626.     else if (type(p) == LST) {
  627.       var_to_user(car(p));   var_to_user(cdr(p));
  628.     }
  629. }
  630.  
  631. var_to_atom(p)
  632.   register LIST *p;
  633. {
  634.   register int t;
  635.  
  636.   if (p != NULL)
  637.     if ((t = type(p)) != LST && !isfunc(t) || t == FUSER)
  638.       rplact(p, SATOM);
  639.     else {
  640.       var_to_atom(car(p));   var_to_atom(cdr(p));
  641.     }
  642. }
  643.  
  644. /* find_labels - change the type of all labels in a PROG to LABL */
  645. find_labels(p)
  646.   LIST *p;
  647. {
  648.   for ( ;  p != NULL;  p = cdr(p))
  649.     if (type(car(p)) == VARI) {
  650.       rplact(car(p), LABL);          /* change the type to LABL */
  651.       rplacd(car(car(p)), cdr(p));    /* label points to next statement */
  652.     }
  653. }
  654.  
  655.  
  656.  
  657. /************************************************************/
  658. /*              garbage collection            */
  659. /************************************************************/
  660.  
  661. /* marktree - recursively marks all used items in a list */
  662. marktree(p)
  663.   register LIST *p;
  664. {
  665.   if (p != NULL) {
  666.     if (type(p) == LST) {
  667.       marktree(car(p));   marktree(cdr(p));
  668.     }
  669.     p->gcbit = USED;
  670.   }
  671. }
  672.  
  673.  
  674. /*********************** storage allocator *****************/
  675.  
  676. char *emalloc(size)
  677.   int size;
  678. {
  679.   char *s, *malloc();
  680.  
  681.   if ((s = malloc(size)) == NULL) {
  682.     fprintf(stderr, "OUT OF MEMORY!!!\n");
  683.     exit();
  684.   }
  685.   return (s);
  686. }
  687.  
  688.  
  689. /* routine to load the library of lisp functions in */
  690. load_library()
  691. {
  692.   FILE *fopen();
  693.  
  694.   if ((fd = fopen("lisplib", "r")) != NULL) {
  695.     interpret();
  696.     fclose(fd);
  697.   }
  698.   fd = stdin;
  699. }
  700.  
  701.  
  702. /* isfunc - returns YES if type t is a user-function or a lisp primitive */
  703. isfunc(t)
  704.   register int t;
  705. {
  706.   return (t==FUSER || t==ADD1 || t==SUB1 || t==PLUS || t==DIFF || t==TIMES ||
  707.       t==QUOTIENT || t==LESSP || t==GREATERP || t==ZEROP || t==NUMBERP ||
  708.       t==FCAR || t==FCDR || t==FCONS || t==FREAD || t==PRINT || t==FNOT||
  709.       t==FAND || t==FOR  || t==FEVAL || t==FEQ || t==FATOM);
  710. }
  711.  
  712.  
  713. debug(p)
  714.   LIST *p;
  715. {
  716.   printf("DEBUG ---\n");  debug2(p);  putchar('\n');
  717. }
  718.  
  719. debug2(p)
  720.   LIST *p;
  721. {
  722.   int t;
  723.  
  724.   if (p != NULL) {
  725.     if ((t = type(p)) == LST) {
  726.       putchar('(');  debug2(car(p));  debug2(cdr(p)); putchar(')');
  727.     }
  728.     else if (t == RATOM) printf("RATOM %f ", p->u.num);
  729.     else if (t == IATOM) printf("IATOM %d ", (int) p->u.num);
  730.     else if (t == SATOM) printf("SATOM %s ", getname(car(p)));
  731.     else printf("FUNC %d ", type(p));
  732.   }
  733. }
  734.  
  735.